home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / DATABASE / NEW194.ZIP;1 / NEW194.PRG < prev    next >
Encoding:
Text File  |  1993-02-18  |  69.9 KB  |  1,783 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: NEW194.PRG
  3. *-- Programmer: Kenneth J. Mayer (CIS: 71333,1030)
  4. *-- Date......: 02/16/1993
  5. *-- Notes.....: The purpose of this file is to provide the routines that have
  6. *--             been updated or are new in LIB194 from LIB193. This is so that
  7. *--             people aren't required to download the whole procedure library
  8. *--             to obtain the new routines.
  9. *--                See WHATS.NEW  attached to this.
  10. *-- WARNING...: If you use WordStar 5.5 (or WordStar in general), the 
  11. *--             upper half of the ASCII character set is not well-liked.
  12. *--             Do not save changes unless you want to wipe out some of the
  13. *--             documentation in DIACRIT and NEWBORDER routines below.
  14. *-------------------------------------------------------------------------------
  15.  
  16. ================================================================================
  17. *-- In STRINGS.PRG
  18. ================================================================================
  19.  
  20. PROCEDURE WordWrap
  21. *-------------------------------------------------------------------------------
  22. *-- Programmer..: David Frankenbach (CIS: 72147,2635)
  23. *-- Date........: 01/14/1993 (Version 1.1)
  24. *-- Notes.......: Wraps a long string, breaking it into strings that have
  25. *--               a maximum length of nWidth. The first output is displayed
  26. *--               @nRow, nCol. Words are not split ...
  27. *-- Written for.: dBASE IV, 1.5
  28. *-- Rev. History: 01/06/1993 -- Original Release (Version 1.0)
  29. *--               01/14/1993 -- Version 1.1 -- Corrected side-effect of 
  30. *--                       destroying string arg, added test for 
  31. *--                       string[nWidth+1] = " "
  32. *-- Calls.......: None
  33. *-- Called by...: Any
  34. *-- Usage.......: do WordWrap with <nRow>, <nCol>, <cString>, <nWidth>
  35. *-- Example.....: do WordWrap with 2,2,cText,38
  36. *-- Returns.....: None
  37. *-- Parameters..: nRow     = Row to display first line at
  38. *--               nCol     = Left side of area to display text at
  39. *--               cString  = text to wrap
  40. *--               nWidth   = Width of area to wrap text in
  41. *-------------------------------------------------------------------------------
  42.  
  43.     parameters nRow, nCol, cString, nWidth
  44.     private cTemp, nI, cStr
  45.     
  46.     cStr = cString                  && work with a COPY of input, to avoid
  47.                                     && destroying original
  48.     
  49.     do while len(cStr) > 0          && while there's something to work on
  50.         if (nWidth < len(cStr))
  51.             nI = nWidth               && look for last " " in first nWidth
  52.             
  53.             if substr(cStr,nI+1,1) # " "
  54.                 do while ( (nI > 0) .and. (substr(cStr,nI,1) # " ") )
  55.                     nI = nI - 1
  56.                 enddo
  57.             endif
  58.             
  59.             if nI = 0                 && no spaces
  60.                 nI = nWidth            && get first nWidth characters
  61.             endif
  62.         else
  63.             nI = len(cStr)         && use the rest of the string
  64.         endif
  65.         
  66.         cTemp = left(cStr,nI)     && get the part we're going to display
  67.         
  68.         if nI < len(cStr)         && remove that part
  69.            cStr = ltrim(substr(cStr,nI + 1))
  70.         else
  71.             cStr = ""
  72.         endif
  73.         
  74.         *-- display it
  75.         @nRow,nCol say cTemp
  76.         *-- move to next row
  77.         nRow = nRow + 1
  78.         
  79.     enddo
  80.     
  81. RETURN
  82. *-- EoP: WordWrap
  83.  
  84. *===============================================================================
  85. *-- In SCREEN.PRG
  86. *===============================================================================
  87.  
  88. FUNCTION NewBorder
  89. *-------------------------------------------------------------------------------
  90. *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
  91. *-- Date........: 01/20/1993
  92. *-- Notes.......: Will save current border setting (the returned value),
  93. *--               and set a new one with one of a set of pre-defined
  94. *--               borders. This will create a new variable if it doesn't
  95. *--               already exist, called: c_Border, which is a PUBLIC Character
  96. *--               variable. The purpose is so that you can keep using this
  97. *--               string for other purpose (i.e., DEFINE WINDOW and such ...)
  98. *-- Written for.: dBASE IV, 1.5
  99. *-- Rev. History: None
  100. *-- Calls.......: None
  101. *-- Called by...: Any
  102. *-- Usage.......: NewBorder("<cStyle>")
  103. *-- Example.....: cOldBorder = NewBorder("K")
  104. *--               @5,10 to 15,60  && draw box with new "border" setting
  105. *--               *-- define a window with new "border" setting
  106. *--               define window wTest from 10,20 to 20,60 &c_Border
  107. *--               set border to &cOldBorder  && reset border to original
  108. *-- Returns.....: Current border setting
  109. *-- Parameters..: cStyle = Style from one of the following:
  110. *--                        A = Double
  111. *--                                     …ÕÕÕÕª
  112. *--                                     ∫    ∫
  113. *--                                     »ÕÕÕÕº
  114. *--                        B = Single
  115. *--                                     ⁄ƒƒƒƒø
  116. *--                                     ≥    ≥
  117. *--                                     ¿ƒƒƒƒŸ
  118. *--                        C = Panel
  119. *--                                     €€€€€€
  120. *--                                     €    €
  121. *--                                     €€€€€€
  122. *--                        D = None
  123. *--                        E = Double Top, Single Left, Right, and Bottom
  124. *--                                      ’ÕÕÕÕ∏
  125. *--                                      ≥    ≥
  126. *--                                      ¿ƒƒƒƒŸ
  127. *--                        F = Single Top, Double Left, Right and Bottom
  128. *--                                      ÷ƒƒƒƒ∑
  129. *--                                      ∫    ∫
  130. *--                                      »ÕÕÕÕº
  131. *--                        G = Double Top, Left, Right, Single Bottom
  132. *--                                      …ÕÕÕÕª
  133. *--                                      ∫    ∫
  134. *--                                      ”ƒƒƒƒΩ
  135. *--                        H = Single Top, Left, Right, Double Bottom
  136. *--                                      ⁄ƒƒƒƒø
  137. *--                                      ≥    ≥
  138. *--                                      ‘ÕÕÕÕæ
  139. *--                        I = Double Top, Single Left and Right, Double Bottom
  140. *--                                      ’ÕÕÕÕ∏
  141. *--                                      ≥    ≥
  142. *--                                      ‘ÕÕÕÕæ
  143. *--                        J = Single Top, Double Left and Right, Single Bottom
  144. *--                                      ÷ƒƒƒƒ∑
  145. *--                                      ∫    ∫
  146. *--                                      ”ƒƒƒƒΩ
  147. *--                        K = Single Top and Left, Double Right and Bottom
  148. *--                                      ⁄ƒƒƒƒ∑
  149. *--                                      ≥    ∫
  150. *--                                      ‘ÕÕÕÕº
  151. *--                        L = Single Top, Double Left, Single Right, Dbl Bottom
  152. *--                                      ÷ƒƒƒƒø
  153. *--                                      ∫    ≥
  154. *--                                      »ÕÕÕÕæ
  155. *--                        M = Double Top and Left, Single Right and Bottom
  156. *--                                      …ÕÕÕÕ∏
  157. *--                                      ∫    ≥
  158. *--                                      ”ƒƒƒƒŸ
  159. *--                        N = Double Top, Single Left, Double Right, Sgl Bottom
  160. *--                                      ’ÕÕÕÕª
  161. *--                                      ≥    ∫
  162. *--                                      ¿ƒƒƒƒΩ
  163. *--                        O = Double Top, Single Left, Double Right and Bottom
  164. *--                                      ’ÕÕÕÕª
  165. *--                                      ≥    ∫
  166. *--                                      ‘ÕÕÕÕº
  167. *--                        P = Double Top, Left, Single Right, Double Bottom
  168. *--                                      …ÕÕÕÕÕ∏
  169. *--                                      ∫     ≥
  170. *--                                      »ÕÕÕÕÕæ
  171. *--                        Q = Single Top, Double Left, Single Right and Bottom
  172. *--                                      ÷ƒƒƒƒƒø
  173. *--                                      ∫     ≥
  174. *--                                      ”ƒƒƒƒƒŸ
  175. *--                        R = Single Top and Left, Double Right, Single Bottom
  176. *--                                      ⁄ƒƒƒƒƒ∑
  177. *--                                      ≥     ∫
  178. *--                                      ¿ƒƒƒƒƒΩ
  179. *--                        S = Panel (sort of) -- more room inside the border.
  180. *--                                      fiflflflflfl›
  181. *--                                      fi     ›
  182. *--                                      fi‹‹‹‹‹›
  183. *-------------------------------------------------------------------------------
  184.  
  185.     parameters cStyle
  186.     cReturn = set("BORDER")    && current border -- if version of dBASE is
  187.                                && less than 1.5, comment this out ...
  188.     
  189.     if type("c_Border") = "U"  && if this is undefined
  190.         public c_Border         &&   declare it as public
  191.     endif
  192.     
  193.     *-- here we go ...
  194.     do case
  195.         case cStyle = "A"   
  196.             c_Border = "DOUBLE"   && pre-defined
  197.         case cStyle = "B"
  198.             c_Border = "SINGLE"   && pre-defined
  199.         case cStyle = "C"
  200.             c_Border = "PANEL"    && pre-defined
  201.         case cStyle = "D"
  202.             c_Border = "NONE"     && pre-defined
  203.         case cStyle = "E"
  204.             *-- items are: top line, bottom line, left line, right line,
  205.             *-- upper left corner, upper right corner, bottom left corner,
  206.             *-- bottom right corner
  207.             c_Border = "205,196,179,179,213,184,192,217"
  208.         case cStyle = "F"
  209.             c_Border = "196,205,186,186,214,183,200,188"
  210.         case cStyle = "G"
  211.             c_Border = "205,196,186,186,201,187,211,189"
  212.         case cStyle = "H"
  213.             c_Border = "196,205,179,179,218,191,212,190"
  214.         case cStyle = "I"
  215.             c_Border = "205,205,179,179,213,184,212,190"
  216.         case cStyle = "J"
  217.             c_Border = "196,196,186,186,214,183,211,189"
  218.         case cStyle = "K"
  219.             c_Border = "196,205,179,186,218,183,212,188"
  220.         case cStyle = "L"
  221.             c_Border = "196,205,186,179,214,191,200,190"
  222.         case cStyle = "M"
  223.             c_Border = "205,196,186,179,201,184,211,217"
  224.         case cStyle = "N"
  225.             c_Border = "205,196,179,186,213,187,192,189"
  226.         case cStyle = "O"
  227.             c_Border = "205,205,179,186,213,187,212,188"
  228.         case cStyle = "P"
  229.             c_Border = "205,205,186,179,201,184,200,190"
  230.         case cStyle = "Q"
  231.             c_Border = "196,196,186,179,214,191,211,217"
  232.         case cStyle = "R"
  233.             c_Border = "196,196,179,186,218,183,192,189"
  234.         case cStyle = "S"
  235.             c_Border = "223,220,222,221,222,221,222,221"
  236.     endcase
  237.     
  238.     set border to &c_Border
  239.  
  240. RETURN cReturn
  241. *-- EoF: NewBorder
  242.  
  243. FUNCTION VidRow
  244. *-------------------------------------------------------------------------------
  245. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  246. *-- Date........: 01/28/1993
  247. *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
  248. *--               to return the ABSOLUTE position of the current ROW on the
  249. *--               screen, despite any active windows, etc.
  250. *--               This is based on original routines by David Frankenbach,
  251. *--               but includes the load/release in one routine, rather
  252. *--               than requiring three functions to perform this ...
  253. *--               ***************************
  254. *--               ** REQUIRES VDCURSOR.BIN **
  255. *--               ***************************
  256. *-- Written for.: dBASE IV, 1.5
  257. *-- Rev. History: None
  258. *-- Calls.......: VDCURSOR.BIN
  259. *-- Called by...: Any 
  260. *-- Usage.......: VidRow()
  261. *-- Example.....: ?VidRow()
  262. *-- Returns.....: Numeric ROW position for current row on screen
  263. *-- Parameters..: None
  264. *-------------------------------------------------------------------------------
  265.  
  266.     private cX
  267.     
  268.     cX = space(2)             && define argument memvar
  269.     load vdcursor             && load the .BIN file
  270.     call vdcursor with cX     && call it with the memvar
  271.     release module vdcursor   && release from memory
  272.  
  273. RETURN (asc(substr(cX,2))-1) && return the value of the absolute cursor position
  274. *-- EoF: VidRow()
  275.  
  276. FUNCTION VidCol
  277. *-------------------------------------------------------------------------------
  278. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  279. *-- Date........: 01/28/1993
  280. *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
  281. *--               to return the ABSOLUTE position of the current COLUMN on the
  282. *--               screen, despite any active windows, etc.
  283. *--               This is based on original routines by David Frankenbach,
  284. *--               but includes the load/release in one routine, rather
  285. *--               than requiring three functions to perform this ...
  286. *--               ***************************
  287. *--               ** REQUIRES VDCURSOR.BIN **
  288. *--               ***************************
  289. *-- Written for.: dBASE IV, 1.5
  290. *-- Rev. History: None
  291. *-- Calls.......: VDCURSOR.BIN
  292. *-- Called by...: Any 
  293. *-- Usage.......: VidCol()
  294. *-- Example.....: ?VidCol()
  295. *-- Returns.....: Numeric COLUMN position for current Col on screen
  296. *-- Parameters..: None
  297. *-------------------------------------------------------------------------------
  298.  
  299.     private cX
  300.     
  301.     cX = space(2)             && define argument memvar
  302.     load vdcursor             && load the .BIN file
  303.     call vdcursor with cX     && call it with the memvar
  304.     release module vdcursor   && release from memory
  305.  
  306. RETURN (asc(substr(cX,1))-1) && return the value of the absolute cursor position
  307. *-- EoF: VidCol()
  308.  
  309. FUNCTION PwdMask
  310. *-------------------------------------------------------------------------------
  311. *-- Programmer..: Kenneth J. Mayer
  312. *-- Date........: 01/29/1993
  313. *-- Notes.......: Designed to display a mask on the screen when a user is
  314. *--               entering a password, rather than a blank surface. Should
  315. *--               handle backspaces to delete ... ASSUMES <cField> is a
  316. *--               memvar.
  317. *--               ***************************
  318. *--               ** REQUIRES VDCURSOR.BIN **
  319. *--               ***************************
  320. *-- Written for.: dBASE IV, 1.5
  321. *-- Rev. History: None
  322. *-- Calls.......: VidRow()             Function in SCREEN.PRG
  323. *--               VidCol()             Function in SCREEN.PRG
  324. *-- Called by...: Any
  325. *-- Usage.......: PwdMask("<cField>"[,<nMaskChar>])
  326. *-- Example.....: @5,10 get password when PwdMask("Password");
  327. *--                      valid required .not. isblank(password);
  328. *--                      error chr(7)+"Password cannot be blank)
  329. *-- Returns.....: .T., and field will have password placed in it when done.
  330. *-- Parameters..: cField    = name of the field
  331. *--               nMaskChar = ASCII code for mask character. OPTIONAL parameter.
  332. *--                           if not provided, will use asterisk. Suggested
  333. *--                           characters include: 176,177,178,219,248,249,254
  334. *-------------------------------------------------------------------------------
  335.  
  336.     parameters cField, nMaskChar
  337.     private nLength, nChar, nX
  338.     
  339.     *-- deal with mask character
  340.     if type("NMASKCHAR") = "L"
  341.         nMaskChar = 42               && *
  342.     endif
  343.     
  344.     lCursor = set("CURSOR") = "ON"
  345.     set cursor off             && rather than have the cursor in the way ...
  346.     nLength = len(&cField.)    && get length of current field
  347.     nChar = 0                  && input character
  348.     nRow = vidrow()            && get absolute cursor location
  349.     nCol = vidcol()            && ditto
  350.     cTemp = ""                 && initialize temp memvar
  351.     do while len(cTemp) < nLength .and. nChar # 13  
  352.                                && loop until we hit end of field
  353.                                && or user presses <Enter>
  354.     
  355.         nChar = inkey(0)        && wait for user to enter something
  356.         
  357.         do case  
  358.                                       
  359.             case nChar = 127                    && <BackSpace>
  360.                 if isblank(cTemp)                && if empty, don't delete anything
  361.                     ?? chr(7)                     && instead, BEEP
  362.                 else
  363.                     cTemp = left(cTemp,len(cTemp)-1)  && backup one
  364.                 endif
  365.                 
  366.             case (nChar => 65 .and. nChar <= 90) .or.;
  367.                  (nChar => 97 .and. nChar <= 122) && alphabetic input only
  368.                 cTemp = cTemp + chr(nChar)         && add character
  369.                 
  370.             case nChar = 13                       && <Enter>
  371.                 exit
  372.                 
  373.             otherwise
  374.                 ?? chr(7)                          && otherwise, BEEP
  375.                 loop
  376.         endcase
  377.         
  378.         *-- create the current "mask", padding with spaces ...
  379.         cMask = replicate(chr(nMaskChar),len(cTemp)) + space(nLength-len(cTemp))
  380.         *-- display it in same color as the current "GET"
  381.         @nRow,nCol get cMask
  382.         clear gets
  383.         *-- put password into current memvar
  384.         store cTemp to &cField.
  385.         
  386.     enddo
  387.     
  388.     *-- turn cursor on if it was prior to this routine
  389.     if lCursor
  390.         set cursor on
  391.     endif
  392.     
  393.     keyboard chr(13)   && send a final <Enter> to exit this GET
  394.     
  395. RETURN .T.
  396. *-- EoF: PwdMask()
  397.  
  398. FUNCTION MsgExp
  399. *-------------------------------------------------------------------------------
  400. *-- Programmer..: Adam Menkes (Borland)
  401. *-- Date........: 02/05/1993
  402. *-- Notes.......: Allows you to display message (or error message), centered
  403. *--               like SET MESSAGE ... with added utility. Does not use
  404. *--               "(Press Space)", which can be annoying. The message and the
  405. *--               line on which it is displayed will be the same color.
  406. *--               Taken from TECHNOTES.
  407. *-- Written for.: dBASE IV, 1.1
  408. *-- Rev. History: 09/xx/1991 -- Original routine
  409. *--               02/05/1993 -- Modified by Lee Hite to handle a string that
  410. *--                             is greater than 80 characters (this can be
  411. *--                             a real problem if the message is in row 24!)
  412. *-- Usage.......: MsgExp("<cExp>")
  413. *-- Example.....: MsgExp("This is a message")
  414. *-- Returns.....: Message displayed (centered) on screen
  415. *-- Parameters..: cExp  = Message to be displayed
  416. *-------------------------------------------------------------------------------
  417.  
  418.     parameters cMsg
  419.     private nLen
  420.     
  421.     nLen = (80-len(trim(cMsg)))/2
  422.  
  423. RETURN space(nLen) + trim(cMsg) + space(nLen+0.5)
  424. *-- EoF: MsgExp
  425.  
  426. FUNCTION YesNoCan
  427. *-------------------------------------------------------------------------------
  428. *-- Programmer..: Miriam Liskin
  429. *-- Date........: 02/01/1993
  430. *-- Notes.......: Asks a yes/no/cancel question in a dialog window/box
  431. *-- Written for.: dBASE IV, 1.1
  432. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  433. *--               04/29/1991 - Modified to Ken Mayer add shadow
  434. *--               05/13/1991 - Modified to Ken Mayer remove need for extra 
  435. *--                            procedures (YES/NO) that were used for returning
  436. *--                            values from Menu
  437. *--                            (suggested by Clinton L. Warren (VBCES))
  438. *--               01/20/1992 - Modified by Martin Leon (HMan) to handle user
  439. *--                            pressing 'Y' or 'N' keys (with ON KEY ...).
  440. *--               06/11/1992 - Modified by Joey Carroll (JOEY) to allow
  441. *--                            answer choices to be "Yes", "No", or "Cancel"
  442. *--                            or to allow for parameters to pass the contents
  443. *--                            of the prompts. If none are passed, they default
  444. *--                            to "Yes", "No", "Cancel". Further modified to
  445. *--                            allow specification of location by row if 
  446. *--                            desired. Window size now varies as parameters 
  447. *--                            dictate.
  448. *--               09/21/1992 - Modified by JOEY to fix bug caused if leading
  449. *--                            blanks in parameters cPrompt1,cPrompt2,cPrompt3
  450. *--                            Corrected example - case pad()="PPAD1"
  451. *--                            instead of          case pad()=PPAD1
  452. *--               02/01/1993 - Mods by Lee Hite: Routine would not wait for
  453. *--                            user response if "default" answer did not match
  454. *--                            one of the prompts. Now first prompt becomes
  455. *--                            default if no match is found on invocation.
  456. *--                            Also, match is no longer case sensitive.  Also
  457. *--                            made window height variable if message
  458. *--                            lines 2 and/or 3 are null strings.  Finally,
  459. *--                            added "confirmation" parameter which when set
  460. *--                            true will force user to press [Enter] before
  461. *--                            function returns.
  462. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  463. *--               CENTER               Procedure in PROC.PRG
  464. *--               ISBLANK()            Function in MISC.PRG, Internal in 1.5
  465. *-- Called by...: Any
  466. *-- Usage.......: YesNoCan("<cAnswer>","<cMess1>","<cMess2>","<cMess3>",;
  467. *--                 "<cPrompt1>","<cPrompt2>","<cPrompt3>",;
  468. *--                  <nTopRow>,"<cColor>",[lConfirm])
  469. *-- Example.....: cAnswer="Y"
  470. *--               cAnswer=YesNoCan(cAnswer,"*** Warning ***",;
  471. *--                            "A serious error has occured.",;
  472. *--                             "Choose carefully.","Proceed",;
  473. *--                             "Retry","Cancel",10,;
  474. *--                             "w+/r,n/w,w+/r")
  475. *--               do case
  476. *--                  case cAnswer="Y"    && OR case pad()="PPAD1"
  477. *--                     * do your thing
  478. *--                  case cAnswer="N"    && OR case pad()="PPAD2"
  479. *--                     skip
  480. *--                  case cAnswer="C"    && OR case pad()="PPAD3"
  481. *--                     * e.g. - return
  482. *--               endcase
  483. *--
  484. *--                 The middle set of colors should be different, as they
  485. *--                 will be the colors of the YES/NO selections ...
  486. *--                 Options may be blank by using nul values ("")
  487. *-- Returns.....: First character of selected pad
  488. *-- Parameters..: cAnswer  =  default value (Yes or No or Cancel) for menu
  489. *--               cMess1   =  First line of Message
  490. *--               cMess2   =  Second line of message
  491. *--               cMess3   =  Third line of message
  492. *--               cPrompt1 =  Optional prompt for left pad
  493. *--               cPrompt2 =  Optional prompt for middle pad
  494. *--               cPrompt3 =  Optional prompt for right pad
  495. *--               nTopRow  =  Optional top row of window
  496. *--               cColor   =  Optional colors for window/menu/box
  497. *--               lConfirm =  Optional "confirmation" parameter -- if true
  498. *--                           user must press [Enter], otherwise pressing
  499. *--                           a valid prompt key automatically returns
  500. *-------------------------------------------------------------------------------
  501.  
  502.    parameter cAnswer,cMess1,cMess2,cMess3,;
  503.       cPrompt1,cPrompt2,cPrompt3,nTopRow,cColor,lConfirm
  504.    private nLMargin,nRMargin,lWrap,nTopRowMax,cKey1,cKey2,cKey3,nWinWidth, ;
  505.       cConfirm, nWinHgth, nMsgRow
  506.     private cPrompt1,cPrompt2,cPrompt3 
  507.     
  508.     *-- save screen so we can restore ...
  509.    save screen to sYesNoCan
  510.    * locate top row of window
  511.    nTopRowMax = iif(set("STATUS") = "OFF",17,14) && protect Status Line
  512.    nTopRow = iif(isblank(nTopRow),14,nTopRow) && no parameter passed
  513.    nTopRow = min(nTopRowMax,nTopRow)
  514.  
  515.    * set pad prompts if none passed
  516.    cPrompt1 = iif(isblank(cPrompt1),"Yes",cPrompt1)
  517.    cPrompt2 = iif(isblank(cPrompt2),"No",cPrompt2)
  518.    cPrompt3 = iif(isblank(cPrompt3),"Cancel",cPrompt3)
  519.    cAnswer = iif(isblank(cAnswer),cPrompt1,cAnswer)
  520.  
  521.    * program bombs if prompts passed contain leading blanks
  522.    cPrompt1 = ltrim(trim(cPrompt1))
  523.    cPrompt2 = ltrim(trim(cPrompt2))
  524.    cPrompt3 = ltrim(trim(cPrompt3))
  525.  
  526.    * determine how wide the window needs to be
  527.    nWinWidth = max(19,len(cPrompt1 + cPrompt2 + cPrompt3) +13)
  528.    nWinWidth = max(nWinWidth,len(cMess1)+4)
  529.    nWinWidth = max(nWinWidth,len(cMess2)+4)
  530.    nWinWidth = max(nWinWidth,len(cMess3)+4)
  531.    * and how high it needs to be
  532.    nWinHgth = iif(""=cMess2,7,8)
  533.    nWinHgth = iif(""=cMess3,nWinHgth-1,nWinHgth)
  534.    * and center it
  535.    define window wYesNoCan from nTopRow,40-(nWinWidth+2)/2 ;
  536.       to nTopRow+nWinHgth-1,40+(nWinWidth+2)/2 double color &cColor.
  537.    define menu mYesNoCan
  538.    define pad pPad1 of mYesNoCan Prompt "["+cPrompt1+"]" ;
  539.       at nWinHgth-3,02
  540.    * center middle prompt between other two, not center of window
  541.    define pad pPad2 of mYesNoCan Prompt "["+cPrompt2+"]" at nWinHgth-3, ;
  542.       ((nWinWidth-len(cPrompt2))/2+(len(cPrompt1)-len(cPrompt3))/2)
  543.    define pad pPad3 of mYesNoCan Prompt "["+cPrompt3+"]"  ;
  544.       at nWinHgth-3,(nWinWidth-3)-(len(cPrompt3))
  545.    on selection pad pPad1 of mYesNoCan deactivate menu
  546.    on selection pad pPad2 of mYesNoCan deactivate menu
  547.    on selection pad pPad3 of mYesNoCan deactivate menu
  548.     
  549.    activate screen
  550.    do shadow with nTopRow,40-(nWinWidth+2)/2,nTopRow+nWinHgth-1, ;
  551.       40+(nWinWidth+2)/2
  552.    activate window wYesNoCan
  553.     
  554.    do center with 0,nWinWidth,"",cMess1       && center the text
  555.    *-- deal with blank message lines
  556.    nMsgRow = 2
  557.    if "" <> cMess2
  558.       do center with nMsgRow,nWinWidth,"",cMess2
  559.       nMsgRow = nMsgRow + 1
  560.    endif
  561.    if "" <> cMess3
  562.       do center with nMsgRow,nWinWidth,"",cMess3
  563.    endif
  564.    *-- deal with user pressing first key of prompt
  565.    cKey1 = left(cPrompt1,1)
  566.    cKey2 = left(cPrompt2,1)
  567.    cKey3 = left(cPrompt3,1)
  568.  
  569.    *-- set [CR] at end of keyboard command depending on "confirm" parameter
  570.    cConfirm = iif(lConfirm,"",chr(13))
  571.  
  572.    on key label &cKey1. keyboard iif( PAD() = "PPAD1", "", ;
  573.       iif(pad() = "PPAD2", chr(19),CHR(4) )) + cConfirm
  574.    on key label &cKey2. keyboard iif( PAD() = "PPAD2",  "", ;
  575.       iif(pad() = "PPAD1",CHR(4),chr(19) )) + cConfirm
  576.    on key label &cKey3. keyboard iif( PAD() = "PPAD3", "", ;
  577.       iif(pad() = "PPAD2", CHR(4),chr(19))) + cConfirm
  578.    clear typeahead
  579.     *-- otherwise deal with regular "menu" abilities
  580.    do case
  581.       case upper(cAnswer)=upper(cKey1)
  582.            activate menu mYesNoCan pad pPad1
  583.       case upper(cAnswer)=upper(cKey2)
  584.            activate menu mYesNoCan pad pPad2
  585.       case upper(cAnswer)=upper(cKey3)
  586.            activate menu mYesNoCan pad pPad3
  587.       otherwise
  588.            activate menu mYesNoCan pad pPad1
  589.    endcase
  590.     
  591.     *-- clear out ON KEY settings ...
  592.    on key label &cKey1.
  593.    on key label &cKey2.
  594.    on key label &cKey3.
  595.     *-- reset environment
  596.    deactivate window wYesNoCan
  597.    release window wYesNoCan
  598.    restore screen from sYesNoCan
  599.    release screen sYesNoCan
  600.    release menu mYesNoCan
  601.  
  602. RETURN upper(substr(prompt(),2,1))
  603. *-- EoF: YesNoCan()
  604.  
  605. *===============================================================================
  606. *-- In PICKLIST.PRG
  607. *===============================================================================
  608.  
  609. PROCEDURE Diacrit
  610. *-------------------------------------------------------------------------------
  611. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  612. *-- Date........: 01/27/1993
  613. *-- Notes.......: Used to insert those letters with diacritical marks into
  614. *--               your input screens. This routine brings up a picklist with
  615. *--               all the standard diacrit characters built into the ASCII
  616. *--               character set. 
  617. *--               NOTE: To use this routine properly, two things must be
  618. *--                done first:
  619. *--                PUBLIC n_RowPop, n_ColPop
  620. *--                a Call to LocPop() should be made with a WHEN clause in
  621. *--                the "get". See example below.
  622. *-- Written for.: dBASE IV, 1.5
  623. *-- Rev. History: 12/28/1992 -- Original
  624. *--               01/27/1993 -- Modified (KJM) to cope with data entry WINDOWS
  625. *--                which includes restoring the active window when done.
  626. *-- Calls.......: LocPop()             Indirectly. FUNCTION in PICKLIST.PRG
  627. *-- Called by...: Any (routine with a GET)
  628. *-- Usage.......: DO Diacrit 
  629. *-- Example.....: public n_RowPop, n_ColPop         && vital
  630. *--               @5,10 get cVar when LocPop(5,10)  && vital
  631. *--               ON KEY LABEL ALT-K DO DIACRIT 
  632. *--               read
  633. *--               on key label alt-k  && release definition
  634. *-- Returns.....: Keyboards character into current "GET"
  635. *-- Parameters..: None
  636. *-------------------------------------------------------------------------------
  637.     
  638.     private nRow, nCol, nRow2, nCol2, cReturn
  639.     on key label alt-k ?? chr(7)  && beep if user tries to call again ...
  640.     
  641.     *-- first things first, define where it's to display
  642.     cWindow = window() && save current window if there is one
  643.     activate screen
  644.     nRow = n_RowPop   && get values from public memvars
  645.     nCol = n_ColPop
  646.     
  647.     *-- bottom right corner of popup ...
  648.     nCol2 = nCol + 5
  649.     nRow2 = nRow + 10
  650.     
  651.     *-- define the popup
  652.     define popup pDiacrit from nRow,nCol to nRow2,nCol2 
  653.     define bar  1 of pDiacrit prompt " "+chr(142)+" "  && é
  654.     define bar  2 of pDiacrit prompt " "+chr(143)+" "  && è
  655.     define bar  3 of pDiacrit prompt " "+chr(146)+" "  && í
  656.     define bar  4 of pDiacrit prompt " "+chr(131)+" "  && É
  657.     define bar  5 of pDiacrit prompt " "+chr(132)+" "  && Ñ
  658.     define bar  6 of pDiacrit prompt " "+chr(133)+" "  && Ö
  659.     define bar  7 of pDiacrit prompt " "+chr(134)+" "  && Ü
  660.     define bar  8 of pDiacrit prompt " "+chr(160)+" "  && †
  661.     define bar  9 of pDiacrit prompt " "+chr(145)+" "  && ë
  662.     define bar 10 of pDiacrit prompt " "+chr(144)+" "  && ê
  663.     define bar 11 of pDiacrit prompt " "+chr(136)+" "  && à
  664.     define bar 12 of pDiacrit prompt " "+chr(137)+" "  && â
  665.     define bar 13 of pDiacrit prompt " "+chr(138)+" "  && ä
  666.     define bar 14 of pDiacrit prompt " "+chr(130)+" "  && Ç
  667.     define bar 15 of pDiacrit prompt " "+chr(139)+" "  && ã
  668.     define bar 16 of pDiacrit prompt " "+chr(140)+" "  && å
  669.     define bar 17 of pDiacrit prompt " "+chr(141)+" "  && ç
  670.     define bar 18 of pDiacrit prompt " "+chr(161)+" "  && °
  671.     define bar 19 of pDiacrit prompt " "+chr(147)+" "  && ì
  672.     define bar 20 of pDiacrit prompt " "+chr(148)+" "  && î
  673.     define bar 21 of pDiacrit prompt " "+chr(149)+" "  && ï
  674.     define bar 22 of pDiacrit prompt " "+chr(162)+" "  && ¢
  675.     define bar 23 of pDiacrit prompt " "+chr(153)+" "  && ô
  676.     define bar 24 of pDiacrit prompt " "+chr(150)+" "  && ñ
  677.     define bar 25 of pDiacrit prompt " "+chr(129)+" "  && Å
  678.     define bar 26 of pDiacrit prompt " "+chr(151)+" "  && ó
  679.     define bar 27 of pDiacrit prompt " "+chr(163)+" "  && £
  680.     define bar 28 of pDiacrit prompt " "+chr(154)+" "  && ö
  681.     define bar 29 of pDiacrit prompt " "+chr(152)+" "  && ò
  682.     define bar 30 of pDiacrit prompt " "+chr(128)+" "  && Ä
  683.     define bar 31 of pDiacrit prompt " "+chr(165)+" "  && •
  684.     define bar 32 of pDiacrit prompt " "+chr(164)+" "  && §
  685.     
  686.     *-- whatta we do with it?
  687.     on selection popup pDiacrit deactivate popup
  688.     activate popup pDiacrit
  689.     cPrompt = prompt()
  690.     
  691.     *--            Esc                ->                  <-
  692.     if lastkey() = 27 .or. lastkey() = 4 .or. lastkey() = 19
  693.         cReturn = ""
  694.     else
  695.         cReturn = substr(cPrompt,2,1)  && get the actual character ...
  696.     endif
  697.     
  698.     *-- remove from memory
  699.     release popup pDiacrit
  700.     *-- reactivate window if there was one ...
  701.     if .not. isblank(cWindow)
  702.         activate window &cWindow
  703.     endif
  704.     *-- put into user's "Get"
  705.     keyboard cReturn
  706.     *-- reset ON KEY definition
  707.     on key label alt-k do diacrit
  708.     
  709. RETURN
  710. *-- EoP: Diacrit
  711.  
  712. FUNCTION LocPop
  713. *-------------------------------------------------------------------------------
  714. *-- Programmer..: Kenneth Chan (:>Zak<:) (CIS: 71542,2712)
  715. *-- Date........: 01/28/1993
  716. *-- Notes.......: Created for diacritical routine above, to determine position
  717. *--               of current "Get", and then decide whether to place upper
  718. *--               left coordinates (in public memvars: n_RowPop, n_ColPop)
  719. *--               of a popup. 
  720. *-- Written for.: dBASE IV, 1.5
  721. *-- Rev. History: 12/25/1992 -- Original
  722. *--               12/28/1992 -- Modified to deal with positioning if get is
  723. *--                to far to the right on the screen, and so on (Ken Mayer).
  724. *--               01/28/1993 -- Modified to handle windows on screen, giving
  725. *--                an absolute address. Requires user to provide coordinates
  726. *--                for upper left corner of window.
  727. *-- Calls.......: VidRow()               Function in SCREEN.PRG
  728. *--               VidCol()               Function in SCREEN.PRG
  729. *-- Called by...: Diacrit   (Indirectly) Procedure in PICKLIST.PRG
  730. *-- Usage.......: LocPop(<nWidth>,<nLength>[,<nWBorder>])
  731. *-- Example.....: @5,10 get cVar when LocPop(5,10)
  732. *-- Returns.....: logical true
  733. *-- Parameters..: nWidth   = width of popup
  734. *--               nLength  = length of popup (how many bars should display on
  735. *--                           screen -- used to determine if displaying above
  736. *--                           or below ROW() of GET)
  737. *--               nWBorder = OPTIONAL -- if there is no border we have to back
  738. *--                            up one, so put a '0' in here if there is no
  739. *--                            border, otherwise, ignore this parameter.
  740. *-------------------------------------------------------------------------------
  741.     
  742.     parameters nWidth,nLength, nWBorder
  743.     private cVar, nRow, nCol
  744.     
  745.     *-- get current "GET"
  746.     cVar = varread()
  747.     
  748.     *-- put current position into column/row ... since cursor was just placed
  749.     *-- into field (assuming called from WHEN clause), we are always on the
  750.     *-- first character in the GET ...
  751.     nRow = VidRow()
  752.     nCol = VidCol() 
  753.     
  754.     if type("NWBORDER") # "L" .and. nWBorder = 0
  755.         nRow = nRow - 1
  756.         nCol = nCol - 1
  757.     endif
  758.     
  759.     *-- add it all up, see if popup coordinates are off the screen
  760.     *-- if so, we need to display the popup UNDER the GET
  761.     if nCol + (len(&cVar)+nWidth+1) > 79 
  762.         nRow = nRow + 1                 
  763.         nCol = 79 - nWidth              && put it right up against edge of screen
  764.     else                               && otherwise, set column position
  765.         nCol = nCol + len(&cVar) + 1    && add length of memvar/get
  766.     endif
  767.     
  768.     *-- now to see if we're going to go off the bottom of the screen
  769.     *-- and deal with _that_ -- displaying popup ABOVE the GET.
  770.     nDisp = val(right(set("DISPLAY"),2))  && (EGAxx ...)
  771.     if nRow + nLength +2 => nDisp - 1  && check for bottom of screen
  772.         nRow = nRow - nLength - 2 
  773.     endif
  774.     
  775.     if type("N_ROWPOP") = "U" .or. type("N_ROWPOP") = "L"
  776.         public n_RowPop,n_ColPop
  777.     endif
  778.     n_RowPop = nRow  && set current position ...
  779.     n_ColPop = nCol
  780.     
  781. RETURN .t.
  782. *-- EoF: LocPop()
  783.  
  784. FUNCTION Pick4
  785. *-------------------------------------------------------------------------------
  786. *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
  787. *-- Date........: 02/16/1993
  788. *-- Notes.......: This is a generic picklist routine.
  789. *-- Written for.: dBASE IV, 1.1
  790. *-- Rev. History: 10/01/1992 -- Original version
  791. *--               11/03/1992 -- Modified to dUFLP it (and use RECOLOR to
  792. *--                ensure that colors are returned properly) -- Ken Mayer
  793. *--               02/16/1993 -- Updated by Keith to deal with small data files.
  794. *-- Calls.......: ReColor              PROCEDURE in PROC.PRG
  795. *-- Called by...: Any
  796. *-- Usage.......: Pick4(nRow,nCol,cTitle,cFileSpecs,cListWhat,nRetChar,;
  797. *--                     nRetType,cColors
  798. *-- Example.....: ?Pick4(10,10,"Order Stock","Stock,InvNum",;
  799. *--                     "left(invno,10)+' '+desc",4,1,"r/w,b/w,w/b")
  800. *-- Returns.....: number of characters from prompt()
  801. *-- Parameters..: nRow        = Upper Left Corner Row
  802. *--               nCol        = Upper Left Corner Column
  803. *--               cTitle      = Title to display at top of list
  804. *--               cFileSpecs  = "FILENAME,ORDER,SET_KEY_TO"
  805. *--               cListWhat   = What should display as prompt
  806. *--               nRetChar    = Number of characters of prompt to return
  807. *--               nReturnType = 0 = KEYB(), 1 = Normal Return
  808. *--               cColors     = Background/Unselected Items,;
  809. *--                             Selected letters/border, selected bar
  810. *--                             example: rg+/gb,w+/b,w+/n
  811. *--                              rg+/gb = unselected items (and background)
  812. *--                              w+/b   = selected letter(s)
  813. *--                              w+/n   = currently highlighted bar
  814. *-------------------------------------------------------------------------------
  815.  
  816.    para nRow,nCol,cTitle,cFileSpecs,cListWhat,nRetChar,nReturnType,cColors
  817.  
  818.    private nLastBar,cTalk,cStatus,cNColor,cBColor,cHColor,nPick,;
  819.            cWindow,cCursor,cAlias,sPick,cAttrib,nLastBar, nDone,;
  820.            nX,nP,nO,aBar,lRefresh,nLCol,nRCol,nPKey,cExact,  ;
  821.            cSeek,nOldRow,nOldWidth,xRetVal,cSetKey
  822.  
  823.     *-- basic environmental stuff
  824.    cTalk = set("talk")
  825.    set talk off
  826.     *-- set default colors
  827.    cNColor = "w/n"
  828.    cBColor = "w+/n"
  829.    cHColor = "n/w"
  830.     *-- if user passed this parameter
  831.    if len(cColors) > 0
  832.       nX = at(",",cColors)
  833.       cNColor = left(cColors,nX-1)
  834.       cColors = substr(cColors,nX+1)
  835.       if len(cColors) > 0
  836.          nX = at(",",cColors)
  837.          cBColor = iif(nX > 0,left(cColors,nX-1),cColors)
  838.          cColors = iif(nX > 0,substr(cColors,nX+1),"")
  839.          if len(cColors) > 0
  840.             cHColor = cColors
  841.         endif
  842.       endif
  843.    endif
  844.     
  845.     *-- save current screen colors and screen, modify environment some more
  846.    cAttrib = set("attr")
  847.    set color to &cHColor,&cNColor
  848.    save screen to sPick
  849.    cStatus = set("status")
  850.    set status off
  851.    restore screen from sPick
  852.    cCursor = set("cursor")
  853.    set cursor off
  854.    cWindow = window()
  855.    activate screen
  856.    cExact = set("exact")
  857.    cSeek = ""
  858.    set exact off
  859.    set near off
  860.  
  861.     *-- display
  862.    @ 9,32 clear to 9,47
  863.    @ 9,32 fill to 11,49 color w/n
  864.    @ 8,31 to 10,48 color &cBColor
  865.    @ 9,32 say " Please wait... " color &cNColor
  866.     
  867.     *-- create the picklist
  868.    declare aBar[10]
  869.    cOrder = ""
  870.    cSetKey = ""
  871.    cFile = cFileSpecs
  872.    nX = at(",",cFileSpecs)
  873.    if nX > 0
  874.       cFile= left(cFileSpecs,nX-1)
  875.       cFileSpecs = substr(cFileSpecs,nX+1)
  876.       if len(cFileSpecs) > 0
  877.          nX = at(",",cFileSpecs)
  878.          cOrder = iif(nX>0,left(cFileSpecs,nX-1),cFileSpecs)
  879.          cFileSpecs = iif(nX>0,substr(cFileSpecs,nX+1),"")
  880.          if len(cFileSpecs) > 0
  881.             cSetKey = cFileSpecs
  882.          endif
  883.       endif
  884.    endif
  885.    cAlias = alias()
  886.    nLastBar = 9
  887.    nP = 1 
  888.    nO = 1
  889.    nDone = 0
  890.    lRefresh = .t.
  891.    lSameFile = (cAlias = upper(cFile))
  892.    use &cFile. again in select() alias picker
  893.    if len(tag(1)) > 0
  894.       set order to tag(1)
  895.    endif
  896.    set deleted on
  897.    if len(trim(cOrder)) > 0
  898.       set order to &cOrder
  899.    endif
  900.    if len(trim(cSetKey)) > 0
  901.       if at(",",cSetKey) > 0
  902.          cSetKey = "range "+ cSetKey
  903.       endif
  904.       set nPKey to &cSetKey
  905.    endif
  906.    go top
  907.    nDone = iif(reccount() < 1,2,0)
  908.    if nRow > 14
  909.       nRow = 14
  910.    endif
  911.    nOldWidth = -1
  912.    nOldRow = -1
  913.    nLastBar = 9
  914.    do while nDone = 0
  915.       if lRefresh .and. .not. eof("picker")
  916.          nWidth = 0
  917.          nX = 0
  918.          do while nX < 8 .and. .not. eof("picker")
  919.             nX = nX + 1
  920.             aBar[nX] = &cListWhat
  921.             if len(aBar[nX]) > nWidth
  922.                nWidth = len(aBar[nX])
  923.             endif
  924.             skip 1
  925.          enddo
  926.          nLastBar = nX
  927.          nLCol = nCol
  928.          nRCol = nLCol + nWidth + 4
  929.          do while (nRCol > 77) .and. (nLCol > 0)
  930.             if nLCol > 1
  931.                nRCol = nRCol - 1
  932.                nLCol = nLCol - 1
  933.             else
  934.                nRCol = 77
  935.             endif
  936.          enddo
  937.          if (nWidth <> nOldWidth) .or. (nLastBar <> nOldRow)
  938.             restore screen from sPick
  939.             @ nRow+1, nLCol+1 fill  to ;
  940.               nRow+nLastBar+2,nRCol+2 color w/n
  941.             @ nRow  , nLCol         to ;
  942.               nRow+nLastBar+1,nRCol   color &cBColor
  943.             @ nRow  , nLCol+1 say '['   color &cBColor
  944.             @ nRow  , nLCol+2 say cTitle color &cNColor
  945.             @ nRow  , nLCol+2+len(cTitle) say ']' color &cBColor
  946.          endif
  947.          @ nRow+1, nLCol+1 clear to ;
  948.            nRow+nLastBar  ,nRCol-1
  949.          @ nRow+1, nLCol+1 fill  to ;
  950.            nRow+nLastBar  ,nRCol-1 color &cBColor
  951.          nOldRow = nLastBar
  952.          nOldWidth = nWidth
  953.          nX = 1
  954.          do while nX <= nLastBar
  955.             @ nX+nRow,nLCol+2 say " "+aBar[nX] color &cNColor
  956.             nX = nX + 1
  957.          enddo
  958.       endif
  959.       if nP > nLastBar
  960.          nP = nLastBar
  961.       endif
  962.       if nO <= nLastBar
  963.          @ nRow+nO, nLCol+2 fill to nRow+nO,nRCol-2 color &cNColor
  964.       endif
  965.       @ nRow+nP, nLCol+2 fill to nRow+nP,nRCol-2 color &cHColor
  966.       nX = at(upper(cSeek),upper(aBar[nP]))
  967.       if nX > 0
  968.          @ nRow+nP,nLCol+2+nX fill to nRow+nP,nLCol+1+nX+len(cSeek) ;
  969.            color &cBColor
  970.       endif
  971.       nO = nP
  972.       *-- start processing key strokes ...
  973.       nPKey = inkey(0)
  974.       do case
  975.       case nPKey = 5                                 && up
  976.          nP = nP - 1
  977.          if nP < 1
  978.             nPKey = 18
  979.             nP = nLastBar
  980.          endif
  981.          cSeek = ""
  982.       case nPKey = 24                                && down
  983.          nP = nP + 1
  984.          if nP > nLastBar
  985.             if .not. eof("picker")
  986.                nPKey = 3
  987.                nP = 1
  988.             else
  989.                nPKey = 0
  990.                nP = nP - 1
  991.             endif
  992.          endif
  993.          cSeek = ""
  994.       endcase
  995.       lRefresh = .t.
  996.       do case
  997.       case nPKey = 18                                && pgup, up
  998.          skip - 16
  999.          if bof()
  1000.             go top
  1001.          endif
  1002.          cSeek = ""
  1003.       case nPKey = 26                                && home
  1004.          go top
  1005.          nP = 1
  1006.          cSeek = ""
  1007.       case nPKey = 2                                 && end
  1008.          go bottom
  1009.          skip - 7
  1010.          if bof()
  1011.             go top
  1012.          else
  1013.             nP = nLastBar
  1014.          endif
  1015.          cSeek = ""
  1016.       case nPKey = 27                                && esc
  1017.          nDone = 1
  1018.       case (nPKey = 13) .or. (nPkey = 23)            && c/r
  1019.          nPick = aBar[nP]
  1020.          nDone = 1
  1021.       case ((nPKey >= asc(" ")) .and. (nPKey <= asc("z"))) .or. (nPKey = 127)
  1022.          if nPKey = 127
  1023.             cSeek = left(cSeek,len(cSeek)-1)
  1024.          else
  1025.             cSeek = cSeek + chr(nPKey)
  1026.          endif
  1027.          if len(trim(tag())) > 0
  1028.             seek(cSeek)
  1029.             if .not. found()
  1030.                seek(upper(cSeek))
  1031.             endif
  1032.          endif
  1033.          if .not. found()
  1034.              cSeek = left(cSeek,len(cSeek)-1)
  1035.              ?? chr(7)
  1036.          endif
  1037.          if len(trim(cSeek)) = 0
  1038.             go top
  1039.          endif
  1040.          lRefresh = .t.
  1041.          nPKey = 3
  1042.       otherwise
  1043.          if (nPKey <> 3)
  1044.             lRefresh = .f.
  1045.          endif
  1046.       endcase
  1047.    enddo
  1048.  
  1049.     *-- return something, unless <Esc> was pressed
  1050.    if nPKey <> 27
  1051.       if nReturnType = 0
  1052.          keyboard chr(26)+chr(25)+left(nPick,nRetChar)+chr(13)
  1053.       endif
  1054.       xRetVal = iif(nReturnType=0,.t.,iif(nPKey=27,"",left(nPick,nRetChar)))
  1055.    else
  1056.       xRetVal = .f.
  1057.    endif
  1058.  
  1059.     *-- cleanup
  1060.    select picker
  1061.    use
  1062.    if len(trim(cAlias)) > 0
  1063.       select (cAlias)
  1064.    endif
  1065.    if len(trim(cWindow)) > 0
  1066.       activate window &cWindow
  1067.    endif
  1068.     do recolor with cAttrib   
  1069.    set status &cStatus
  1070.    set talk &cTalk
  1071.    set cursor &cCursor
  1072.    set exact &cExact
  1073.    restore screen from sPick
  1074.  
  1075. RETURN xRetVal
  1076. *-- EoF: Pick4()
  1077.  
  1078. *===============================================================================
  1079. *-- In FIELDS.PRG
  1080. *===============================================================================
  1081.  
  1082. FUNCTION FldWidth
  1083. *-------------------------------------------------------------------------------
  1084. *-- Programmer..: Kenneth Chan [HazMatZak] (CIS: 71542,2712)
  1085. *-- Date........: 01/28/1993
  1086. *-- Notes.......: Returns the width of a field, without having to read the
  1087. *--               .DBF structure into a file and use low-level functions ...
  1088. *-- Written for.: dBASE IV, 1.5
  1089. *-- Rev. History: None
  1090. *-- Calls.......: None
  1091. *-- Called by...: Any
  1092. *-- Usage.......: FldWidth(<nField>)
  1093. *-- Example.....: ?FldWidth(3)
  1094. *-- Returns.....: Numeric value
  1095. *-- Parameters..: nField = field number in file structure
  1096. *-------------------------------------------------------------------------------
  1097.  
  1098.     parameters nField
  1099.     private nReturn, cFldType, cFldName
  1100.     
  1101.     cFldName = field(nField)   && get the field name
  1102.     cFldType = type(cFldName)  && get the type ...
  1103.     do case
  1104.         case cFldType = "L"
  1105.             nReturn = 1
  1106.         case cFldType = "D"
  1107.             nReturn = 8
  1108.         case cFldType = "C"
  1109.             nReturn = len(&cFldName.)
  1110.         case cFldType $ "NF"
  1111.             nReturn = len(transform(&cFldName.,"@L"))
  1112.         otherwise
  1113.             nReturn = 0
  1114.     endcase
  1115.     
  1116. RETURN nReturn
  1117. *-- EoF: FldWidth()
  1118.  
  1119. FUNCTION FldDec
  1120. *-------------------------------------------------------------------------------
  1121. *-- Programmer..: Kenneth Chan [HazMatZak] (CIS: 71542,2712)
  1122. *-- Date........: 01/28/1993
  1123. *-- Notes.......: Returns the number of decimal places of a numeric field. 
  1124. *-- Written for.: dBASE IV, 1.5
  1125. *-- Rev. History: None
  1126. *-- Calls.......: None
  1127. *-- Called by...: Any
  1128. *-- Usage.......: FldDec(<nField>)
  1129. *-- Example.....: ?FldDec(3)
  1130. *-- Returns.....: Numeric value, 0 if non-numeric field type
  1131. *-- Parameters..: nField = field number in file structure
  1132. *-------------------------------------------------------------------------------
  1133.  
  1134.     parameters nField
  1135.     private nReturn, cTemplate, cFldName
  1136.     
  1137.     cFldName = field(nField)
  1138.     if type(cFldName) $ "NF"    && if it's numeric/float type
  1139.         cTemplate = transform(&cFldName.,"@L")
  1140.         nReturn = at(".",cTemplate)
  1141.         if nReturn > 0
  1142.             nReturn = len(cTemplate) - nReturn
  1143.         endif
  1144.     else
  1145.         nReturn = 0
  1146.     endif
  1147.  
  1148. RETURN nReturn
  1149. *-- EoF: FldDec()
  1150.  
  1151. *===============================================================================
  1152. *-- In FINANCE.PRG
  1153. *===============================================================================
  1154.  
  1155. FUNCTION Irr2 && {version 1.01}
  1156. *-------------------------------------------------------------------------------
  1157. *-- Programmer...: Ron Allen (CIS: 71201,2502)
  1158. *-- Date.........: 01/25/1993
  1159. *-- Notes........: Returns internal rate of return on an investment from
  1160. *--                evenly-spaced periodic cashflows. The UDF simultaneously
  1161. *--                accumulates the periodic Net Present Values of the
  1162. *--                individual cashflows along with the first derivative of
  1163. *--                the function. After the summation is completed for each
  1164. *--                guess, the guess is adjusted by subtracting the ratio
  1165. *--                of the function to its derivative.
  1166. *-- Written for..: dBASEIV, version 1.5, tested on build xx71
  1167. *-- Rev. History.: 1.01  01/28/93 - to add missing private variables. To
  1168. *--                count iterations without sign change in PV. Move
  1169. *--                division by nRatio outside inner loop.
  1170. *-- Calls........: None
  1171. *-- Called by....: Any
  1172. *-- Usage........: Irr2(<nN>, <cFlow>, <lSw>, <nGuess>)
  1173. *-- Example......: Rate = Irr2(6, "Cash", Switch, .01)
  1174. *-- Returns......: Internal Rate of Return.
  1175. *-- Parameters...: nN     = number of cashflows in model
  1176. *--                cFlow  = name of the array holding the cashflows
  1177. *--                lSw    = name of a logical variable to be switched to
  1178. *--                         indicate valid IRR returned (.t.).
  1179. *--                nGuess = optional guess for initialing search.
  1180. *-------------------------------------------------------------------------------
  1181.    parameters nN, cFlow, lSw, nGuess
  1182.    private nI, nPosVal, nNegVal, nCurVal, nIRR, nNuDelta, nOlDelta, nBigchange
  1183.    private nSignChng, nDiscount, nRatio, nSumPV, nCurrPV, nSumDeriv, nOldPV
  1184.    private nIters, lSw1
  1185.    store 0 to nI, nPosVal, nNegVal, nIters
  1186.    store .t. to lSw
  1187.    store .f. to lSw1
  1188.    declare nCashFlow[nN]
  1189.  
  1190.     *--  Transfer cashflows to a private array and separate negatives from
  1191.     *--  positives
  1192.    do while nI < nN
  1193.        nI = nI+1
  1194.        store &cFlow[nI] to nCashFlow[nI], nCurVal
  1195.        if nCurVal < 0
  1196.            nNegVal = nNegVal + nCurVal
  1197.        else
  1198.            nPosVal = nPosVal + nCurVal
  1199.        endif
  1200.    enddo
  1201.    if nNegVal = 0 .or. nPosVal = 0
  1202.        wait "Must have at least one positive and one negative value"
  1203.    endif
  1204.  
  1205.     *-- Use initializing guess if provided, otherwise calculate from
  1206.     *-- weighted average returns.
  1207.         
  1208.    if pcount() = 4
  1209.       nIRR = nGuess
  1210.    else
  1211.        nIRR = ((-nPosVal/nNegVal)-1)/nN
  1212.    endif
  1213.     
  1214.     *-- Housekeeping summary accumulators, etc., before entering loop
  1215.    store 1 to nNuDelta, nOlDelta
  1216.    store 0 to nSignChng, nBigChange
  1217.  
  1218.     *--  Loop until estimated rate indicated accuracy
  1219.    do while abs(nNuDelta) > .000001
  1220.        store 0 to nI, nSumPV, nSumDeriv
  1221.     
  1222.         *-- Set up cumulative denominator to calculate incremental NPV
  1223.        nDiscount = 1
  1224.        nRatio = 1 + nIRR
  1225.        do while nI < nN
  1226.            nI = nI+1
  1227.            nDiscount = nDiscount/nRatio
  1228.         
  1229.             *-- Calculate incremental PV and add to sum
  1230.            nCurrPV = nDiscount * nCashFlow[nI]
  1231.            nSumPV = nSumPV + nCurrPV
  1232.         
  1233.             *-- Add incremental first derivative to derivative sum
  1234.            nSumDeriv = nSumDeriv - nI * nCurrPV
  1235.        enddo
  1236.     
  1237.         *-- count iterations and test for sign change of future value
  1238.        if .not. lSw1 .and. nIters > 0
  1239.            lSw1 = iif(sign(nOldPV) = sign(nSumPV),.f.,.t.)
  1240.        endif
  1241.        nIters = nIters + 1
  1242.        nOldPV = nSumPV
  1243.  
  1244.  
  1245.         *-- Calculate indicated change in IRR
  1246.        nNuDelta = nRatio * nSumPV/nSumDeriv
  1247.     
  1248.         *-- Test for big changes in adjusted IRR, limit to 10 times
  1249.         *-- current guess for IRR and count big changes.
  1250.        if abs(nNuDelta/nIRR) > 10
  1251.            nNuDelta = sign(nNuDelta) * 10 * nIRR
  1252.            nBigChange = nBigChange + 1
  1253.        endif
  1254.        nIRR = nIRR - nNuDelta   && Make adjustment to guess for IRR
  1255.     
  1256.         *-- Count reversals in adjustments to limit hunting
  1257.        nSignChng = nSignChng + iif(sign(nNuDelta) + sign(nOlDelta) = 0,1,0)
  1258.        nOlDelta = nNuDelta
  1259.     
  1260.         *-- Test for hunting, too many bigchanges or too large a solution
  1261.         *-- and set external switch if abnormal exit is used.
  1262.        if nSignChng + nBigChange > 10 .or. abs(nIRR) > 100 .or. ;
  1263.           (nIters > 9 .and. .not. lSw1)
  1264.            store .f. to lSw
  1265.            exit
  1266.        endif
  1267.    enddo
  1268.  
  1269. RETURN nIRR
  1270. *-- EoF: Irr2()
  1271.  
  1272. FUNCTION Mirr  && {version 1.0}
  1273. *-------------------------------------------------------------------------------
  1274. *-- Programmer...: Ron Allen (CIS: 71201,2502)
  1275. *-- Date.........: 01/27/1993
  1276. *-- Notes........: Used to calculate the Modified Internal Rate of Return
  1277. *--                for evenly-spaced periodic cashflows. The modifications
  1278. *--                assume that more realistic investment models should 
  1279. *--                account for the cost of borrowing or the lower 'safe'
  1280. *--                rate for keeping reserve funds to cover outlays and the
  1281. *--                fact that reinvestments will be made at some other rate 
  1282. *--                than the IRR itself. This model calculates the answer
  1283. *--                directly, therefore more rapidly than the iterative
  1284. *--                approach used by IRR. 
  1285. *-- Written for..: dBASEIV,  version 1.5, tested on build xx71
  1286. *-- Rev. History.: None
  1287. *-- Calls........: None
  1288. *-- Called by....: Any
  1289. *-- Usage........: Mirr(<nN>, <cFlow>, <nRrate>, <nFrate>)
  1290. *-- Example......: Rate = Mirr(6, "Cash", .1, .14)
  1291. *-- Returns......: Modified Internal Rate of Return per period.
  1292. *-- Parameters...: nN     = number of cashflows in model
  1293. *--                cFlow  = name of the array holding the cashflows
  1294. *--                nRrate = Reinvestment rate for positive cashflows. 
  1295. *--                nFrate = 'Safe' rate expected on reserve funds to 
  1296. *--                          cover disbursements.
  1297. *-------------------------------------------------------------------------------
  1298.    parameters nN, cFlow, nRrate, nFrate
  1299.    private nI, nNegVal, nPosVal, nCurVal
  1300.    store 0 to nI, nNegVal, nPosVal
  1301.  
  1302.     *-- Pass through array once computing present value of negative
  1303.     *-- cashflows at 'safe' rate and present value of positive values
  1304.     *-- at the reinvestment rate.
  1305.    do while nI < nN
  1306.        nI = nI+1
  1307.        nCurVal = &cFlow[nI]
  1308.        nCurVal = nCurVal*(1+iif(nCurVal<0,nFrate,nRrate))^-(nI-1)
  1309.        if nCurVal < 0
  1310.            nNegVal = nNegVal + nCurVal
  1311.        else
  1312.            nPosVal = nPosVal + nCurVal
  1313.        endif
  1314.    enddo
  1315.    if abs(nNegVal) = 0 .or. nPosVal = 0
  1316.        wait " There must be at least one negative and one positive value! "
  1317.        return 0
  1318.    endif
  1319.  
  1320.     *-- Calculate the rate of return required to yield a future value
  1321.     *-- of the positive values reinvested at nRrate from the present
  1322.     *-- value of the negative values invested at the 'safe' rate.
  1323.  
  1324. RETURN ((-nPosVal * (1+nRrate)^(nN-1))/nNegVal)^(1/(nN-1))-1
  1325. *-- EoF: Mirr()
  1326.  
  1327. FUNCTION Xmirr  && {version 1.01}
  1328. *-------------------------------------------------------------------------------
  1329. *-- Programmer...: Ron Allen (CIS: 71201,2502)
  1330. *-- Date.........: 01/27/1993
  1331. *-- Notes........: Used to calculate the Modified Internal Rate of Return
  1332. *--                from cashflows on random dates. Except for the need to 
  1333. *--                supply both the dates of transactions and the cashflows
  1334. *--                in an 'nN' by 2 array, the other inputs are the same as 
  1335. *--                in Mirr(). Dates may be in random order except for the
  1336. *--                first date. The first date in the array establishes 
  1337. *--                the date to which present value applies. Enter 'Safe'
  1338. *--                rate for reserves and 'Reinvestment' rate for positive 
  1339. *--                cashflows as annual rates, e.g., .075 for 7.5%.
  1340. *-- Written for..: dBASEIV, version 1.5, tested on build xx71
  1341. *-- Rev. History.: 1.01 01/27/93 - to allow entry of 'Safe' reserve rate
  1342. *--                  and 'Reinvestment' rate as annual rates rather than 
  1343. *--                  rates. Also, to return the 'effective' rate of interest
  1344. *--                  when compounded daily, rather than the 'nominal' rate.   
  1345. *-- Calls........: None
  1346. *-- Called by....: Any
  1347. *-- Usage........: Xmirr(<nN>, <cFlow>, <nRrate>, <nFrate>)
  1348. *-- Example......: Rate = Xmirr(5, "Cash", .14, .1)
  1349. *-- Returns......: Annualized Effective Modified Internal Rate of Return 
  1350. *--                based on daily compounded interest.   
  1351. *-- Parameters...: nN     = number of cashflows in model
  1352. *--                cFlow  = name of 'nN' by 2 array holding the dates (col 1)
  1353. *--                          and cashflow amounts (col 2). 
  1354. *--                nRrate = Reinvestment rate for positive cashflows. 
  1355. *--                nFrate = 'Safe' rate expected on reserve funds to 
  1356. *--                          cover disbursements.
  1357. *-------------------------------------------------------------------------------
  1358.    parameters nN, cFlow, nRrate, nFrate
  1359.    private nI, nCurVal, nNegVal, nPosVal, dPDate
  1360.    private dMaxDate, dCurDate, nCurN, nMirr
  1361.    store 0 to nI, nNegVal, nPosVal
  1362.    store (1+nRrate)^(1/365)-1 to nRrate
  1363.    store (1+nFrate)^(1/365)-1 to nFrate
  1364.    store &cFlow[1,1] to dPDate
  1365.    dMaxDate = dPDate
  1366.  
  1367.    do while nI < nN
  1368.        nI = nI+1
  1369.        nCurVal = &cFlow[nI,2]
  1370.        dCurDate = &cFlow[nI,1]
  1371.        dMaxDate = max(dCurDate,dMaxDate)
  1372.        nCurN = dCurDate-dPDate
  1373.        nCurVal = nCurVal/(1+iif(nCurVal<0,nFrate,nRrate))^nCurN
  1374.        if nCurVal < 0
  1375.            nNegVal = nNegVal + nCurVal
  1376.        else
  1377.            nPosVal = nPosVal + nCurVal
  1378.        endif
  1379.    enddo
  1380.    if nNegVal = 0 .or. nPosVal = 0
  1381.        wait " There must be at least one negative and one positive value! "
  1382.        return 0
  1383.    endif
  1384.    nN = dMaxDate - dPDate
  1385.    nMirr = ((-nPosVal * (1+nRrate)^(nN-1))/nNegVal)^(1/(nN-1))-1
  1386.  
  1387. RETURN (1+nMirr)^365-1
  1388. *-- EoF: Xmirr()
  1389.  
  1390. FUNCTION Xirr   && {version 1.01}
  1391. *-------------------------------------------------------------------------------
  1392. *-- Programmer...: Ron Allen (CIS: 71201,2502)
  1393. *-- Date.........: 01/25/1993
  1394. *-- Notes........: Used to calculate the Internal Rate of Return from
  1395. *--                cashflows on random dates. Except for the need to 
  1396. *--                supply both the dates of transactions and the cashflows
  1397. *--                in an 'nN' by 2 array, the other inputs are the same as 
  1398. *--                in Irr(). Dates may be in random order except for the
  1399. *--                first date. The first date in the array establishes 
  1400. *--                the date to which present value applies.
  1401. *-- Written for..: dBASEIV, version 1.5, tested on build xx71
  1402. *-- Rev. History.: 1.01 - 01/28/93 - to return 'effective' rate of interest
  1403. *--                when compounded daily rather than the 'nominal' rate.
  1404. *--                Also to count iterations without a sign change in PV. 
  1405. *--                Move division by nRatio outside inner loop.
  1406. *-- Calls........: None
  1407. *-- Called by....: Any
  1408. *-- Usage........: Irr(<nN>, <cFlow>, <lSw>, <nGuess>)
  1409. *-- Example......: Rate = Irr(5, "Cash", "Switch", .01)
  1410. *-- Returns......: Effective Internal Rate of Return.
  1411. *-- Parameters...: nN     = number of cashflows in model
  1412. *--                cFlow  = name of the 'nN' by 2 array holding the 
  1413. *--                         dates (col 1) and cashflows (col 2). Dates
  1414. *--                         may be entered in any order except for the 
  1415. *--                         date, which is the date to which present
  1416. *--                         value applies.
  1417. *--                lSw    = name of a logical variable to be switched to
  1418. *--                         indicate valid IRR returned (.t.).
  1419. *--                nGuess = optional guess for initializing search.
  1420. *-------------------------------------------------------------------------------
  1421.    parameters nN, cFlow, lSw, nGuess
  1422.    private nI, nPosVal, nNegVal, nCurVal, nIRR, nNuDelta, nOlDelta, nBigchange
  1423.    private nSignChng, nRatio, dPDate, dMaxDate, nCurrPV, nSumDeriv
  1424.    private nSumPV, dCurDate, nIters, lSw1
  1425.    store 0 to nI, nPosVal, nNegVal, nIters
  1426.    Store .t. to lSw
  1427.    declare nCashFlow[nN,2]
  1428.    store &cFlow[1,1] to dMaxDate, dPDate
  1429.    store .f. to lSw1
  1430.  
  1431.     *-- Transfer cashflows to a private array and separate negatives from
  1432.     *-- positives. Find last date. 
  1433.    do while nI < nN
  1434.        nI = nI+1
  1435.        store &cFlow[nI,1] to nCashFlow[nI,1], dCurDate
  1436.        store &cFlow[nI,2] to nCashFlow[nI,2], nCurVal
  1437.        store max(dCurDate,dMaxDate) to dMaxDate
  1438.        if nCurVal < 0
  1439.            nNegVal = nNegVal + nCurVal
  1440.        else
  1441.            nPosVal = nPosVal + nCurVal
  1442.        endif
  1443.    enddo
  1444.    if nNegVal = 0 .or. nPosVal = 0
  1445.        wait "Must have at least one positive and one negative value"
  1446.    endif
  1447.  
  1448.     *-- Use initializing guess if provided, otherwise calculate from
  1449.     *-- weighted average returns.
  1450.    if pcount() = 4
  1451.       nIRR = nGuess
  1452.    else
  1453.         nIRR = (((nPosVal+nNegVal-ncashflow[1,2])/-nCashFlow[1,2])-1)/;
  1454.                (dMaxDate-dPDate)
  1455.    endif
  1456.  
  1457.     *-- Housekeeping summary accumulators, etc., before entering loop
  1458.    store 1 to nNuDelta, nOlDelta
  1459.    store 0 to nSignChng, nBigChange
  1460.  
  1461.     *-- Loop until estimated rate indicated accuracy
  1462.    do while abs(nNuDelta) > .000001
  1463.        store 0 to nI, nSumPV, nSumDeriv
  1464.        store 1 + nIrr to nRatio
  1465.        do while nI < nN
  1466.            nI = nI+1
  1467.          
  1468.             *-- Calculate incremental PV and add to sum
  1469.            nCurrPV =  nCashFlow[nI,2] / nRatio^(nCashFlow[nI,1] - dPDate)
  1470.            nSumPV = nSumPV + nCurrPV
  1471.                 
  1472.             *-- Add incremental first derivative to derivative sum
  1473.            nSumDeriv = nSumDeriv - (nCashFlow[nI,1] - dPDate) * nCurrPV
  1474.        enddo
  1475.  
  1476.         *-- count iterations and test for sign change of future value
  1477.        if .not. lSw1 .and. nIters > 0
  1478.            lSw1 = iif(sign(nOldPV) = sign(nSumPV),.f.,.t.)
  1479.        endif
  1480.        nIters = nIters + 1
  1481.        nOldPV = nSumPV
  1482.     
  1483.         *-- Calculate indicated change in IRR
  1484.        nNuDelta = nRatio * nSumPV/nSumDeriv
  1485.     
  1486.         *-- Test for big changes in adjusted IRR, limit to 10 times
  1487.         *-- current guess for IRR and count big changes.
  1488.        if abs(nNuDelta/nIRR) > 10
  1489.            nNuDelta = sign(nNuDelta) * 10 * nIRR
  1490.            nBigChange = nBigChange + 1
  1491.        endif
  1492.        nIRR = nIRR - nNuDelta   && Make adjustment to guess for IRR
  1493.     
  1494.         *-- Count reversals in adjustments to limit hunting
  1495.        nSignChng = nSignChng + iif(sign(nNuDelta) + sign(nOlDelta) = 0,1,0)
  1496.        nOlDelta = nNuDelta
  1497.     
  1498.         *-- Test for hunting, too many bigchanges or too large a solution
  1499.         *-- and set external switch if abnormal exit is used.
  1500.        if nSignChng + nBigChange > 10 .or. abs(nIRR) > 100 .or. ;
  1501.             (nIters > 9 .and. .not. lSw1)
  1502.            store .f. to lSw
  1503.            exit
  1504.        endif
  1505.    enddo
  1506.  
  1507. RETURN (1+nIrr)^365 -1
  1508. *-- EoF: Xirr()
  1509.  
  1510. FUNCTION FVirr  && {version 1.01}
  1511. *-------------------------------------------------------------------------------
  1512. *-- Programmer...: Ron Allen (CIS: 71201,2502)
  1513. *-- Date.........: 01/28/1993
  1514. *-- Notes........: Returns same roots as Irr(), but averages 20% faster. 
  1515. *--                Irr() searches for the roots of NPV (Net Present Value),
  1516. *--                while FVirr() searches for the same roots of NFV (Net
  1517. *--                Future Value), both with respect to the rate of return.
  1518. *--                The user may wish to use this UDF in place of Irr() and
  1519. *--                use Irr() as an alternate to help locate more multiple
  1520. *--                solutions. The reason this UDF is 'usually' faster is due
  1521. *--                to the fact that the NFV curve is 'usually' steeper as
  1522. *--                it crosses the zero axis.
  1523. *-- Written for..: dBASEIV, version 1.5, tested on build xx71
  1524. *-- Rev. History.: 1.01  01/28/93 - Modified Irr() to use Net Future Value
  1525. *--                curve instead of Net Present Value curve.
  1526. *-- Calls........: None
  1527. *-- Called by....: Any
  1528. *-- Usage........: Irr(<nN>, <cFlow>, <lSw>, <nGuess>)
  1529. *-- Example......: Rate = Irr(6, "Cash", Switch, .01)
  1530. *-- Returns......: Internal Rate of Return.
  1531. *-- Parameters...: nN     = number of cashflows in model
  1532. *--                cFlow  = name of the array holding the cashflows
  1533. *--                lSw    = name of a logical variable to be switched to
  1534. *--                         indicate valid IRR returned (.t.).
  1535. *--                nGuess = optional guess for initialing search.
  1536. *-------------------------------------------------------------------------------
  1537.  
  1538.    parameters nN, cFlow, lSw, nGuess
  1539.    private nI, nPosVal, nNegVal, nCurVal, nIRR, nNuDelta, nOlDelta, nBigchange
  1540.    private nSignChng, nDiscount, nRatio, nSumFV, nCurrFV, nSumDeriv, nOldFV
  1541.    private nIters, lSw1
  1542.    store 0 to nI, nPosVal, nNegVal, nIters
  1543.    store .t. to lSw
  1544.    store .f. to lSw1
  1545.    declare nCashFlow[nN]
  1546.  
  1547.     *-- Transfer cashflows to a private array and separate negatives from
  1548.     *-- positives
  1549.    do while nI < nN
  1550.        nI = nI+1
  1551.        store &cFlow[nI] to nCashFlow[nI], nCurVal
  1552.        if nCurVal < 0
  1553.            nNegVal = nNegVal + nCurVal
  1554.        else
  1555.            nPosVal = nPosVal + nCurVal
  1556.        endif
  1557.    enddo
  1558.    if nNegVal = 0 .or. nPosVal = 0
  1559.        wait "Must have at least one positive and one negative value"
  1560.    endif
  1561.  
  1562.     *-- Use initializing guess if provided, otherwise calculate from
  1563.     *-- weighted average returns.
  1564.    if pcount() = 4
  1565.       nIRR = nGuess
  1566.    else
  1567.        nIRR = ((-nPosVal/nNegVal)-1)/nN
  1568.    endif
  1569.     
  1570.     *-- Housekeeping summary accumulators, etc., before entering loop
  1571.    store 1 to nNuDelta, nOlDelta
  1572.    store 0 to nSignChng, nBigChange
  1573.  
  1574.     *-- Loop until estimated rate indicated accuracy
  1575.    do while abs(nNuDelta) > .000001
  1576.        store 0 to nI, nSumFV, nSumDeriv
  1577.     
  1578.         *-- Set up cumulative denominator to calculate incremental NFV   
  1579.        nRatio = 1 + nIRR
  1580.        nDiscount = nRatio^nN
  1581.        do while nI < nN
  1582.            nI = nI+1
  1583.            nDiscount = nDiscount/nRatio
  1584.                 
  1585.             *-- Calculate incremental FV and add to sum
  1586.            nCurrFV = nDiscount * nCashFlow[nI]
  1587.            nSumFV = nSumFV + nCurrFV
  1588.         
  1589.             *-- Add incremental first derivative to derivative sum
  1590.            nSumDeriv = nSumDeriv - nI * nCurrFV
  1591.        enddo
  1592.     
  1593.         *-- count iterations and test for sign change of future value
  1594.        if .not. lSw1 .and. nIters > 0
  1595.            lSw1 = iif(sign(nOldFV) = sign(nSumFV),.f.,.t.)
  1596.        endif
  1597.        nIters = nIters + 1
  1598.        nOldFV = nSumFV
  1599.  
  1600.         *-- Calculate indicated change in IRR
  1601.        nNuDelta = nRatio * nSumFV/nSumDeriv
  1602.     
  1603.         *-- Test for big changes in adjusted IRR, limit to 10 times
  1604.         *-- current guess for IRR and count big changes.
  1605.        if abs(nNuDelta/nIRR) > 10
  1606.            nNuDelta = sign(nNuDelta) * 10 * nIRR
  1607.            nBigChange = nBigChange + 1
  1608.        endif
  1609.        nIRR = nIRR - nNuDelta   && Make adjustment to guess for IRR
  1610.     
  1611.         *-- Count reversals in adjustments to limit hunting
  1612.        nSignChng = nSignChng + iif(sign(nNuDelta) + sign(nOlDelta) = 0,1,0)
  1613.        nOlDelta = nNuDelta
  1614.             
  1615.         *-- Test for hunting, too many bigchanges or too large a solution
  1616.         *-- and set external switch if abnormal exit is used.
  1617.        if nSignChng + nBigChange > 10 .or. abs(nIRR) > 100 .or. ;
  1618.              (nIters > 9 .and. .not. lSw1)
  1619.            store .f. to lSw
  1620.            exit
  1621.        endif
  1622.    enddo
  1623.  
  1624. RETURN nIRR
  1625. *-- EoF: FVirr()
  1626.  
  1627. FUNCTION FVxirr  && {version 1.01}
  1628. *-------------------------------------------------------------------------------
  1629. *-- Programmer...: Ron Allen (CIS: 71201,2502)
  1630. *-- Date.........: 01/28/1993
  1631. *-- Notes........: Same as Xirr() except that the Net Future Value (NFV)
  1632. *--                function is used instead of the Net Present Value (NPV)
  1633. *--                function. The roots are the same, but this function is
  1634. *--                usually faster for the same reasons that FVirr() is
  1635. *--                faster than Irr(). As in Xirr(), all dates except the 
  1636. *--                first date in the array may be in random order. The first 
  1637. *--                date in the nN by 2 array along with the maximum date
  1638. *--                establishes the range of the investment analysis. 
  1639. *-- Written for..: dBASEIV, version 1.5, tested on build xx71
  1640. *-- Rev. History.: 1.01 - 01/28/93 - Modified Xirr() to find roots of the
  1641. *--                 Net Future Value curve.
  1642. *-- Calls........: None
  1643. *-- Called by....: Any
  1644. *-- Usage........: Irr(<nN>, <cFlow>, <lSw>, <nGuess>)
  1645. *-- Example......: Rate = Irr(5, "Cash", Switch, .01)
  1646. *-- Returns......: Effective Internal Rate of Return.
  1647. *-- Parameters...: nN     = number of cashflows in model
  1648. *--                cFlow  = name of the 'nN' by 2 array holding the 
  1649. *--                         dates (col 1) and cashflows (col 2). Dates
  1650. *--                         may be entered in any order except for the 
  1651. *--                         date, which is the date to which present
  1652. *--                         value applies.
  1653. *--                lSw    = name of a logical variable to be switched to
  1654. *--                         indicate valid IRR returned (.t.).
  1655. *--                nGuess = optional guess for initializing search.
  1656. *-------------------------------------------------------------------------------
  1657.    parameters nN, cFlow, lSw, nGuess
  1658.    private nI, nPosVal, nNegVal, nCurVal, nIRR, nNuDelta, nOlDelta, nBigchange
  1659.    private nSignChng, nRatio, dPDate, dMaxDate, nCurrFV, nSumDeriv
  1660.    private nSumFV, dCurDate, lSw1, nIters
  1661.    store 0 to nI, nPosVal, nNegVal, nIters
  1662.    Store .t. to lSw
  1663.    declare nCashFlow[nN,2]
  1664.    store &cFlow[1,1] to dMaxDate, dPDate
  1665.  
  1666.     *-- Transfer cashflows to a private array and separate negatives from
  1667.     *-- positives. Find last date. 
  1668.     
  1669.    do while nI < nN
  1670.        nI = nI+1
  1671.        store &cFlow[nI,1] to nCashFlow[nI,1], dCurDate
  1672.        store &cFlow[nI,2] to nCashFlow[nI,2], nCurVal
  1673.        store max(dCurDate,dMaxDate) to dMaxDate
  1674.        if nCurVal < 0
  1675.            nNegVal = nNegVal + nCurVal
  1676.        else
  1677.            nPosVal = nPosVal + nCurVal
  1678.        endif
  1679.    enddo
  1680.    if nNegVal = 0 .or. nPosVal = 0
  1681.        wait "Must have at least one positive and one negative value"
  1682.    endif
  1683.  
  1684.     *-- Use initializing guess if provided, otherwise calculate from
  1685.     *-- weighted average returns.
  1686.    if pcount() = 4
  1687.       nIRR = nGuess
  1688.    else
  1689.        nIRR = (((nPosVal+nNegVal-ncashflow[1,2])/-nCashFlow[1,2])-1)/;
  1690.                 (dMaxDate-dPDate)
  1691.    endif
  1692.  
  1693.     *-- Housekeeping summary accumulators, etc., before entering loop
  1694.    store 1 to nNuDelta, nOlDelta
  1695.    store 0 to nSignChng, nBigChange
  1696.    store .f. to lSw1
  1697.  
  1698.     *-- Loop until estimated rate indicated accuracy
  1699.    do while abs(nNuDelta) > .000001
  1700.        store 0 to nI, nSumFV, nSumDeriv
  1701.        store 1 + nIrr to nRatio
  1702.        do while nI < nN
  1703.            nI = nI+1
  1704.         
  1705.             *-- Calculate incremental FV and add to sum
  1706.            nCurrFV =  nCashFlow[nI,2] * nRatio^(dMaxDate - nCashFlow[nI,1])
  1707.            nSumFV = nSumFV + nCurrFV
  1708.                 
  1709.             *-- Add incremental first derivative to derivative sum
  1710.            nSumDeriv = nSumDeriv + (dMaxDate - nCashFlow[nI,1]) * nCurrFV
  1711.        enddo
  1712.     
  1713.         *-- count iterations and test for sign change of future value
  1714.        if .not. lSw1 .and. nIters > 0
  1715.            lSw1 = iif(sign(nOldFV) = sign(nSumFV),.f.,.t.)
  1716.        endif
  1717.        nIters = nIters + 1
  1718.        nOldFV = nSumFV
  1719.  
  1720.         *-- Calculate indicated change in IRR
  1721.        nNuDelta = nRatio * nSumFV/nSumDeriv
  1722.  
  1723.         *-- Test for big changes in adjusted IRR, limit to 10 times
  1724.         *-- current guess for IRR and count big changes.
  1725.        if abs(nNuDelta/nIRR) > 10
  1726.            nNuDelta = sign(nNuDelta) * 10 * nIRR
  1727.            nBigChange = nBigChange + 1
  1728.        endif
  1729.        nIRR = nIRR - nNuDelta   && Make adjustment to guess for IRR
  1730.     
  1731.         *-- Count reversals in adjustments to limit hunting
  1732.        nSignChng = nSignChng + iif(sign(nNuDelta) + sign(nOlDelta) = 0,1,0)
  1733.        nOlDelta = nNuDelta
  1734.  
  1735.         *-- Test for hunting, too many bigchanges or too large a solution
  1736.         *-- and set external switch if abnormal exit is used.
  1737.         if nSignChng + nBigChange > 10 .or. abs(nIRR) > 100 .or. ;
  1738.               (nIters > 9 .and. .not. lSw1)
  1739.            store .f. to lSw
  1740.            exit
  1741.        endif
  1742.    enddo
  1743.  
  1744. RETURN (1+nIrr)^365 -1
  1745. *-- EoF: FVxirr()
  1746.  
  1747. *===============================================================================
  1748. *-- In FILES.PRG
  1749. *===============================================================================
  1750.  
  1751. FUNCTION Used
  1752. *-------------------------------------------------------------------------------
  1753. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1754. *-- Date........: 02/28/1992
  1755. *-- Notes.......: Created because the picklist routine by Malcolm Rubel
  1756. *--               from DBA Magazine (11/91) calls a function that checks
  1757. *--               to see if a DBF file is open ... 
  1758. *-- Written for.: dBASE IV, 1.5
  1759. *-- Rev. History: 05/15/1992 -- Original
  1760. *--               02/08/1993 -- Discovered (thanks to Jay, and then Malcolm)
  1761. *--               a much simpler way to do this ...
  1762. *-- Called by...: Any
  1763. *-- Calls.......: None
  1764. *-- Usage.......: Used("<cFile>")
  1765. *-- Example.....: if used("Library")
  1766. *--                  select library
  1767. *--               else
  1768. *--                  select select()
  1769. *--                  use library
  1770. *--               endif
  1771. *-- Returns.....: Logical (.t. if file is in use, .f. if not)
  1772. *-- Parameters..: cFile = file to check for
  1773. *-------------------------------------------------------------------------------
  1774.     
  1775.     parameters cFile
  1776.     
  1777. RETURN (select(cFile) # 0)
  1778. *-- EoF: Used()
  1779.  
  1780. *-------------------------------------------------------------------------------
  1781. *-- End of Program: NEW194.PRG
  1782. *-------------------------------------------------------------------------------
  1783.